home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
ng_clone.arc
/
NG_CLONE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-28
|
53KB
|
1,385 lines
{$M 4096,0,0} {Reduce stack and heap}
{$R-,I-} {Cut off range and I/O checking}
program ng_clone; {After all, that's what it is; Thank you, Mr. Norton, you are among my heroes!}
uses crt,tesstp5; {TESS could probably be the 4.0 version also}
type gentry= record {General entry type}
filptr:longint;
name:string[40];
end;
textel= record {Text-mode screen element}
cha:byte;
att:byte;
end;
fiftylinebuf= array[1..50,1..80] of textel; {Video buffer types}
twelwebuf= array[1..12,1..80] of textel;
savedline= array[1..80] of textel;
var screen:fiftylinebuf absolute $B800:$0000; {Text-mode screen, should be B000:0000h on monochrome}
csr:word absolute $0040:$0060; {Low-memory cursor info}
screenmode:word absolute $0040:$0049; {Low-memory screen info}
numrows:word absolute $0040:$0084; {Low-memory screen info}
savedscreen:fiftylinebuf; {Buffer to save current screen on entry}
smallscreen:twelwebuf; {Buffer to hold screen template}
menuline:array[0..1] of savedline; {Buffer to hold screen template}
largescreen:array[0..1] of savedline; {Buffer to hold screen template}
scrollbuffer:array[0..511] of string[84]; {Buffer to hold guide text entry}
infobuffer:array[0..511] of longint; {Buffer to hold guide file info}
seealso:array[0..19] of gentry; {Buffer to hold guide file info}
menu:array[0..2] of string[9]; {Buffer to hold static part of guide menu structure}
mennu:array[0..3,0..8] of gentry; {Buffer to hold variable part of guide menu structure}
backstack:array[0..3] of byte; {TESS background stack}
itemlist:array[0..3] of byte; {Menu structure info}
menuplaces,menulengths:array[0..6] of byte; {Stacks for nested menu structures}
errorinfo:array[3..6] of string[14]; {Buffer for error messages}
f:file; {The guide file}
propath,homedir,streng:string; {String variables, mostly for path and file use}
tsrstring:string[8]; {TESS ID string}
parent:array[0..3] of longint; {Stack for nested menu structures}
poffset:array[0..3] of word; {Stack for nested menu structures}
pcurpos:array[0..3] of byte; {Stack for nested menu structures}
defptr,stackptr:pointer; {TESS pointers}
previous,next:longint; {Previous and next entry}
idnum,i,j,offset,ch,id,bufferlength,savedcsr:word; {Word variables}
erro,wix,wiy,curpos,entrytype,seealsonum,sapos,level,scrtypeflag,startline,
txtattri,a1,a2,a3,a4,mlevel,xchoice,ychoice,menux,menuy,menuantal,menunr:byte; {Byte variables}
procedure hidecrsr; {Make cursor invisible on CGA,EGA or VGA}
begin
inline($B4/$01/$B5/$20/$CD/$10);
end;
function restorecrsr(crsr:word):boolean; {Restore saved cursor on CGA,EGA or VGA}
inline($B4/$01/$59/$CD/$10);
function key:word; {Keyboard interrupt}
inline($CD/$16);
procedure keyread(var karakter:word); {Readkey replacement}
var tch:char;
begin
karakter:=key;
if (lo(karakter)=0) then {If extended key, add 256 to value of key code}
begin
tch:=char(hi(karakter));
karakter:=ord(tch)+256;
end
else {Else return key code as is}
begin
tch:=char(lo(karakter));
karakter:=ord(tch);
end;
end;
procedure writestring(cux,cuy,startattr,change,extra:byte;cus:string); {Direct screen write}
var jcount,ycount,tmpchr:byte;
jch:char;
begin
jcount:=0;ycount:=0;txtattri:=startattr;
repeat
inc(jcount);
jch:=cus[jcount];
if jch<>'^' then {If not NG control code, write character as is}
begin
if jch=#255 then {Expand spaces}
begin
inc(jcount);
jch:=cus[jcount];
for ycount:=ycount to ycount+ord(jch) do
begin
screen[cuy,cux+ycount].cha:=32;
screen[cuy,cux+ycount].att:=txtattri;
end;
end
else
begin
screen[cuy,cux+ycount].cha:=ord(jch);
screen[cuy,cux+ycount].att:=txtattri;
inc(ycount);
end;
end
else {Control code found!}
begin
inc(jcount);
jch:=cus[jcount];
if ((jch='A') or (jch='a')) then {Color attribute command}
begin
inc(jcount);
jch:=cus[jcount];
if change=1 then
begin
if ((ord(jch)>47) and (ord(jch)<58)) then txtattri:=ord(jch)-48 else
if ((ord(jch)>64) and (ord(jch)<71)) then txtattri:=ord(jch)-55;
txtattri:=16*txtattri;
end;
inc(jcount);
jch:=cus[jcount];
if change=1 then
begin
if ((ord(jch)>47) and (ord(jch)<58)) then txtattri:=txtattri+ord(jch)-48 else
if ((ord(jch)>64) and (ord(jch)<71)) then txtattri:=txtattri+ord(jch)-55;
end;
end
else if ((jch='C') or (jch='c')) then {Difficult character}
begin
inc(jcount);
jch:=cus[jcount];
if ((ord(jch)>47) and (ord(jch)<58)) then tmpchr:=ord(jch)-48 else
if ((ord(jch)>64) and (ord(jch)<71)) then tmpchr:=ord(jch)-55;
tmpchr:=16*tmpchr;
inc(jcount);
jch:=cus[jcount];
if ((ord(jch)>47) and (ord(jch)<58)) then tmpchr:=tmpchr+ord(jch)-48 else
if ((ord(jch)>64) and (ord(jch)<71)) then tmpchr:=tmpchr+ord(jch)-55;
screen[cuy,cux+ycount].cha:=tmpchr;
screen[cuy,cux+ycount].att:=txtattri;
inc(ycount);
end
else if ((jch='b') or (jch='B')) then {Boldface (?)}
begin
if change=1 then
begin
if txtattri=a1 then txtattri:=a3 else txtattri:=a1;
end;
end
else if ((jch='u') or (jch='U')) then {Underline (?)}
begin
if change=1 then
begin
if txtattri=a1 then txtattri:=a2 else txtattri:=a1;
end;
end
else if jch='^' then {Write control character itself}
begin
screen[cuy,cux+ycount].cha:=ord(jch);
screen[cuy,cux+ycount].att:=txtattri;
inc(ycount);
end;
end;
until jcount>=length(cus);
if extra>0 then {If desired, fill with blanks}
begin
while ycount<extra do
begin
screen[cuy,cux+ycount].cha:=32;
screen[cuy,cux+ycount].att:=txtattri;
inc(ycount);
end;
end;
end;
procedure threenitvars; {Initialize variables}
begin
menunr:=0;
level:=0;
curpos:=0;
offset:=0;
menux:=3;
menuy:=0;
mlevel:=0;
xchoice:=0;
ychoice:=0;
sapos:=0;
wix:=0;wiy:=0;
txtattri:=a1;
end;
procedure twonitvars; {Initialize variables}
begin
threenitvars;
menuplaces[0]:=5;
menuplaces[1]:=15;
menuplaces[2]:=28;
menuplaces[3]:=39;
menuplaces[4]:=0;
menuplaces[5]:=0;
menuplaces[6]:=0;
menulengths[0]:=20;
menulengths[1]:=20;
menulengths[2]:=20;
menulengths[3]:=0;
menulengths[4]:=0;
menulengths[5]:=0;
menulengths[6]:=0;
for j:=2 to 79 do smallscreen[1,j].cha:=205;
for j:=2 to 79 do smallscreen[2,j].cha:=0;
end;
procedure initvars; {Initialize variables}
var str5:string;
begin
a1:=$70; {Color attribute for normal text}
a2:=$7E; {Color attribute for underline}
a3:=$7F; {Color attribute for boldface}
a4:=$1E; {Cursor color attribute}
startline:=0;
scrtypeflag:=0;
twonitvars;
errorinfo[3]:='File not found';
errorinfo[4]:='Not an NG file';
errorinfo[5]:='Unexpected EOF';
errorinfo[6]:='Corrupted file';
menu[0]:='Expand';
menu[1]:='Search...';
menu[2]:='Options';
str5:='';propath:=paramstr(0);
while (pos('\',propath)>0) do
begin
str5:=str5+copy(propath,1,pos('\',propath));
propath:=copy(propath,pos('\',propath)+1,length(propath)-(pos('\',propath)+1));
end;
propath:=str5;
end;
procedure initscreen; {Read screen template from disk}
var sf:file;
numread:word;
begin
assign(sf,propath+'ng_clone.scr');
reset(sf,1);
blockread(sf,smallscreen,sizeof(smallscreen),numread);
blockread(sf,menuline[1],sizeof(menuline[1]),numread);
for i:=1 to 80 do largescreen[0,i]:=smallscreen[5,i];
for i:=1 to 80 do largescreen[1,i]:=smallscreen[11,i];
close(sf);
end;
procedure removecursor; {Next follows different cursor procedures}
var sl:byte;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
writestring(2,4+curpos+sl,a1,1,78,scrollbuffer[curpos+offset]);
end;
procedure insertcursor; {Another cursor procedure}
var sl:byte;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
writestring(2,4+curpos+sl,a4,0,78,scrollbuffer[curpos+offset]);
end;
procedure removemenucursor; {Another cursor procedure}
var sl:byte;
cursor:string[78];
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
if menux>2 then cursor:=' '+mennu[menux-3,0].name+' ' else
cursor:=' '+menu[menux]+' ';
writestring(menuplaces[menux]-1,2+sl,txtattri,0,0,cursor);
end;
procedure insertmenucursor; {Another cursor procedure}
begin
txtattri:=a4;
removemenucursor;
txtattri:=a1;
end;
procedure movemenucursor(direction:byte); {Another cursor procedure}
var sl:byte;
begin
if ((entrytype=1) or (level=0)) then
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
txtattri:=a3;
removemenucursor;
if direction=0 then
begin
if menux>0 then dec(menux) else menux:=2+menuantal;
end
else
begin
if menux<2+menuantal then inc(menux) else menux:=0;
end;
insertmenucursor;
for j:=1 to 80 do menuline[0][j]:=screen[2+sl,j];
end;
end;
procedure removemlcursor; {Another cursor procedure}
var cursor:string[78];
begin
if ((menux-3=xchoice) and (menuy=ychoice)) then cursor:=#251+' '+mennu[menux-3,menuy+1].name else
cursor:=' '+mennu[menux-3,menuy+1].name;
while length(cursor)<menulengths[menux]+3 do cursor:=cursor+' ';
writestring(2+wix,2+menuy+wiy,txtattri,0,0,cursor);
end;
procedure insertmlcursor; {Another cursor procedure}
begin
txtattri:=a4;
removemlcursor;
txtattri:=a1;
end;
procedure removeseealso; {Another cursor procedure}
var addo,sl:byte;
cursor:string[78];
begin
addo:=0;
if scrtypeflag=0 then sl:=startline else sl:=0;
for j:=0 to sapos do
begin
if j>0 then inc(addo,length(seealso[j-1].name)+2);
end;
cursor:=' '+seealso[sapos].name+' ';
writestring(13+addo,2+sl,txtattri,0,0,cursor);
end;
procedure insertseealso; {Another cursor procedure}
begin
txtattri:=a4;
removeseealso;
txtattri:=a1;
end;
procedure moveseealso(direction:byte); {You'd never guess: another cursor procedure}
begin
if seealsonum<>255 then
begin
removeseealso;
if direction=0 then
begin
if sapos>0 then dec(sapos) else sapos:=seealsonum;
end
else
begin
if sapos<seealsonum then inc(sapos) else sapos:=0;
end;
insertseealso;
end;
end;
procedure frame1(w,d:byte); {Frame of line-drawing charcters used for menu}
begin
writestring(wix+1,wiy+1,a1,0,0,' ');
for i:=2 to d-1 do
begin
writestring(1+wix,i+wiy,a1,0,0,' ');
writestring(w+wix,i+wiy,a1,0,0,' ');
end;
writestring(wix+1,wiy+d,a1,0,0,' ');
for i:=2 to w-1 do writestring(wix+i,wiy+d,a1,0,0,' ');
writestring(wix+i+1,wiy+1,a1,0,0,' ');
writestring(wix+i+1,wiy+d,a1,0,0,' ');
end;
procedure createsmall; {Save current screen and create small screen}
begin
savedscreen:=screen;
hidecrsr;
for i:=1 to 12 do for j:=1 to 80 do screen[i+startline,j]:=smallscreen[i,j];
writestring(5,2+startline,a3,0,0,menu[0]);
writestring(15,2+startline,a3,0,0,menu[1]);
writestring(28,2+startline,a3,0,0,menu[2]);
writestring(39,2+startline,a3,0,0,mennu[0,0].name);
if menuantal>1 then
begin
i:=length(mennu[0,0].name);
menuplaces[4]:=43+i;
writestring(43+i,2+startline,a3,0,0,mennu[1,0].name);
end;
if menuantal>2 then
begin
inc(i,length(mennu[1,0].name));
menuplaces[5]:=47+i;
writestring(47+i,2+startline,a3,0,0,mennu[2,0].name);
end;
if menuantal>3 then
begin
inc(i,length(mennu[2,0].name));
menuplaces[6]:=51+i;
writestring(51+i,2+startline,a3,0,0,mennu[3,0].name);
end;
i:=0;
while ((i<bufferlength+1) and (i<8)) do
begin
writestring(2,4+i+startline,a1,1,78,scrollbuffer[i]);inc(i);
end;
for i:=1 to 12 do for j:=1 to 80 do smallscreen[i,j]:=screen[i+startline,j];
insertmenucursor;
screen[5+startline,80].att:=$40;
for j:=1 to 80 do menuline[0][j]:=screen[2+startline,j];
end;
procedure blank(width,height:byte); {Blank part of screen}
begin
for i:=2 to height do for j:=1 to width do
begin
screen[wiy+i,wix+j].att:=a1;
screen[wiy+i,wix+j].cha:=0;
end;
end;
procedure makemenu(num:byte); {Make pull-down menu}
var windstart,sl:byte;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
if (menulengths[num]+menuplaces[num]+5>79) then windstart:=79-(menulengths[num]+5) else windstart:=menuplaces[num]-2;
wix:=windstart-1;wiy:=2+sl;
blank(menulengths[num]+4,itemlist[num-3]+1);
frame1(menulengths[num]+5,1+itemlist[num-3]);
for i:=1 to itemlist[num-3]-1 do
begin
writestring(4+wix,1+i+wiy,a1,0,0,mennu[num-3,i].name);
end;
if num-3=xchoice then
begin
writestring(2+wix,2+ychoice+wiy,a1,0,0,#251);
end;
insertmlcursor;
mlevel:=1;
end;
procedure writeseealsos(possible_offset:byte); {Write seealso entries}
var satmp:word;
begin
if seealsonum<>255 then
begin
j:=0;satmp:=0;
for i:=0 to seealsonum do
begin
writestring(14+j,2+possible_offset,a1,0,0,seealso[i].name);
inc(j,length(seealso[i].name)+2);
if i<seealsonum then
begin
if (15+j+length(seealso[i+1].name)>79) then
begin
satmp:=i;
i:=seealsonum;
end
else satmp:=0;
end;
end;
if satmp>0 then seealsonum:=satmp;
insertseealso;
end;
end;
procedure makesmall(vertical_offset:byte); {Repaint small screen}
begin
if ((entrytype=1) or (level=0)) then
begin
for i:=1 to vertical_offset do for j:=1 to 80 do screen[i,j]:=savedscreen[i,j];
for j:=1 to 80 do screen[vertical_offset+1,j]:=smallscreen[1,j];
for j:=1 to 80 do screen[vertical_offset+2,j]:=menuline[0][j];
for i:=3 to 12 do for j:=1 to 80 do screen[i+vertical_offset,j]:=smallscreen[i,j];
for i:=(13+vertical_offset) to lo(numrows)+1 do for j:=1 to 80 do screen[i,j]:=savedscreen[i,j];
end
else
begin
for i:=1 to vertical_offset do for j:=1 to 80 do screen[i,j]:=savedscreen[i,j];
for j:=1 to 80 do screen[vertical_offset+1,j]:=smallscreen[1,j];
for j:=1 to 80 do screen[vertical_offset+2,j]:=menuline[1][j];
for i:=3 to 12 do for j:=1 to 80 do screen[i+vertical_offset,j]:=smallscreen[i,j];
for i:=(13+vertical_offset) to lo(numrows)+1 do for j:=1 to 80 do screen[i,j]:=savedscreen[i,j];
writeseealsos(vertical_offset);
end;
if entrytype=1 then
begin
if curpos>7 then
begin
inc(offset,curpos-7);
curpos:=7;
end;
end;
if entrytype=1 then insertcursor;
for i:=5 to 10 do screen[i+vertical_offset,80].att:=$07;
i:=(((curpos+offset)*6) div (bufferlength+1))+5;
if i>10 then i:=10;
screen[i+vertical_offset,80].att:=$40;
end;
procedure makelarge; {Repaint large screen}
var add:byte;
begin
if ((entrytype=1) or (level=0)) then
begin
for j:=1 to 80 do screen[1,j]:=smallscreen[1,j];
for j:=1 to 80 do screen[2,j]:=menuline[0][j];
for i:=3 to 10 do for j:=1 to 80 do screen[i,j]:=smallscreen[i,j];
for i:=11 to lo(numrows)-1 do for j:=1 to 80 do screen[i,j]:=largescreen[0,j];
for j:=1 to 80 do screen[lo(numrows),j]:=largescreen[1,j];
for j:=1 to 80 do screen[lo(numrows)+1,j]:=smallscreen[12,j];
end
else
begin
for j:=1 to 80 do screen[1,j]:=smallscreen[1,j];
for j:=1 to 80 do screen[2,j]:=menuline[1][j];
for i:=3 to 10 do for j:=1 to 80 do screen[i,j]:=smallscreen[i,j];
for i:=11 to lo(numrows)-1 do for j:=1 to 80 do screen[i,j]:=largescreen[0,j];
for j:=1 to 80 do screen[lo(numrows),j]:=largescreen[1,j];
for j:=1 to 80 do screen[lo(numrows)+1,j]:=smallscreen[12,j];
writeseealsos(0);
end;
if offset+lo(numrows)-4>bufferlength then
begin
if bufferlength>offset+lo(numrows)-4 then
begin
add:=offset-bufferlength+lo(numrows)-4;
inc(curpos,add);
offset:=bufferlength-lo(numrows)+4;
end
else
begin
inc(curpos,offset);
offset:=0;
end;
end;
i:=0;
while ((i+offset<bufferlength+1) and (i<lo(numrows)-3)) do
begin
writestring(2,4+i,a1,1,78,scrollbuffer[i+offset]);inc(i);
end;
if i<lo(numrows)-3 then for i:=i to lo(numrows)-4 do
begin
writestring(2,4+i,a1,0,78,' ');
end;
if entrytype=1 then
begin
if curpos>7 then add:=curpos-7 else add:=0;
end
else
begin
add:=0;
end;
for i:=4 to 11 do for j:=2 to 79 do smallscreen[i,j]:=screen[i+add,j];
if entrytype=1 then insertcursor;
for i:=5 to lo(numrows)-1 do screen[i,80].att:=$07;
i:=(((curpos+offset)*(lo(numrows)-5)) div (bufferlength+1))+5;
if i>lo(numrows)-1 then i:=lo(numrows)-1;
screen[i,80].att:=$40;
if mlevel=1 then makemenu(menux);
end;
procedure usage; {Write usage info}
begin
writeln('NG_CLONE USAGE :');
writeln('------------------');
writeln;
writeln(' ng_clone <'+#123+'d:\dir\'+#125+'file'+#123+'.ext'+#125+'> '+#123+
'<d:\ngdir>'+#125+' <+/-> :run NG_CLONE (see below)');
writeln(' ng_clone </u> or </U> :remove NG_CLONE if resident');
writeln(' ng_clone </?> or </h> or </H> :show this usage information');
writeln;
writeln(' The +/- entry is NOT optional, but used by NG_CLONE to determine whether or');
writeln(' not to install itself as a resident program.');
end;
procedure slutlort(b:byte); {Exit on error and display relevant error message}
begin
if b>3 then close(f);
if b>2 then
begin
write('NG_CLONE ERROR #');write(b);writeln(': '+errorinfo[b]+', cannot proceed');
end;
if b<3 then usage;
halt(0);
end;
procedure sllut(b:byte); {Error handler without exit, just indicating the error type}
var sl:byte;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
if b>3 then close(f);
writestring(4,4+sl,a1,0,74,' '+errorinfo[b]+' - Press any key');
erro:=1;
end;
function decrypt(b:byte):byte; {Decrypt byte from NG format}
begin
if ((b mod 32)>=16) then b:=b-16 else b:=b+16;
if ((b mod 16)>=8) then b:=b-8 else b:=b+8;
if ((b mod 4)>=2) then b:=b-2 else b:=b+2;
decrypt:=b;
end;
function read_byte:byte; {Read and decrypt byte}
var tb:byte;
numread:word;
begin
blockread(f,tb,1,numread);
tb:=decrypt(tb);
read_byte:=tb;
end;
function read_word:word; {Read and decrypt word}
var tw:word;
tb:byte;
begin
tb:=read_byte;
tw:=tb;
tb:=read_byte;
inc(tw,(tb*256));
read_word:=tw;
end;
function read_long:longint; {Read and decrypt longint}
var tl:longint;
tw:word;
begin
tw:=read_word;
tl:=tw;
tw:=read_word;
inc(tl,(tw*65536));
read_long:=tl;
end;
procedure read_menu; {Read a menu structure into the menu buffer}
var items:word;
begin
mennu[menunr,0].filptr:=filepos(f)-2;
seek(f,filepos(f)+2);
items:=read_word;
itemlist[menunr]:=items;
seek(f,filepos(f)+20);
for i:=1 to items-1 do
begin
mennu[menunr,i].filptr:=read_long;
end;
i:=filepos(f);
inc(i,(items*8));
seek(f,i);
for i:=0 to items-1 do
begin
j:=0;
repeat
mennu[menunr,i].name[j+1]:=chr(read_byte);
inc(j);
until (mennu[menunr,i].name[j]=#0);
mennu[menunr,i].name[0]:=chr(j-1);
if j-1>menulengths[menunr+3] then menulengths[menunr+3]:=j-1;
end;
seek(f,filepos(f)+1);
end;
procedure skip_short_long; {Skip procedure for the initial menu seek}
var length:word;
begin
length:=read_word;
seek(f,filepos(f)+22+length);
end;
procedure read_header(modf:byte); {Read NG file header and enter the guide name in the screen template}
var guidenavn:string;
buf:array[0..377] of byte;
numread:word;
begin
blockread(f,buf,sizeof(buf),numread);
if ((buf[0]<>78) or (buf[1]<>71)) then {If the two first characters in the file are not 'NG', the file is no guide}
begin
if modf=0 then slutlort(4) else sllut(4);
end;
menuantal:=buf[6];
i:=0;
repeat
guidenavn[i+1]:=chr(buf[i+8]);
inc(i);
until (buf[i+8]=0);
guidenavn[0]:=chr(i);
guidenavn:=' The Norton Guide to '+guidenavn+' ';
for i:=1 to length(guidenavn) do
begin
smallscreen[1,39-(length(guidenavn) div 2)+i].cha:=ord(guidenavn[i]);
end;
seek(f,378);
end;
procedure read_menus(modf:byte); {Initial menu seek, indexing the whole file}
begin
repeat
id:=read_word;
if id<2 then skip_short_long
else
if id=2 then
begin
read_menu;
inc(menunr);
end
else
if (id<>5) then
begin
if (filesize(f)<>filepos(f)) then
begin
if modf=0 then slutlort(5) else sllut(5); {NG file error}
end
else id:=5;
end;
until (id=5);
if (menunr<>menuantal) then
begin
if modf=0 then slutlort(6) else sllut(6); {Incomplete file}
end;
end;
procedure read_strings(totnum:word); {Read null-terminated strings into scroll buffer}
var stringchar:byte;
begin
for i:=1 to totnum do
begin
j:=0;
repeat
stringchar:=read_byte;
inc(j);
scrollbuffer[i-1][j]:=chr(stringchar);
until stringchar=0;
scrollbuffer[i-1][0]:=chr(j-1);
end;
bufferlength:=totnum-1;
for j:=bufferlength+1 to 511 do scrollbuffer[j]:='';
end;
procedure read_short_entry; {Read short entry from file and wring some information out of it}
var items:word;
begin
seek(f,filepos(f)+2);
items:=read_word;
seek(f,filepos(f)+20);
for i:=1 to items do
begin
seek(f,filepos(f)+2);
infobuffer[i-1]:=read_long;
end;
read_strings(items);
entrytype:=1;
end;
procedure read_long_entry; {Read long entry information}
var linens,dlength,seealso_num:word;
prev,nxt:longint;
stringchar:byte;
begin
seek(f,filepos(f)+2);
linens:=read_word;
dlength:=read_word;
seek(f,filepos(f)+10);
prev:=read_long;
nxt:=read_long;
read_strings(linens);
if dlength<>0 then {If there are seealso entries, read them}
begin
seealso_num:=read_word;
for i:=1 to seealso_num do
begin
if i<21 then seealso[i-1].filptr:=read_long else seek(f,filepos(f)+4);
end;
for i:=1 to seealso_num do
begin
if i<21 then
begin
j:=0;
repeat
stringchar:=read_byte;
inc(j);
seealso[i-1].name[j]:=chr(stringchar);
until stringchar=0;
seealso[i-1].name[0]:=chr(j-1);
end;
end;
seealsonum:=seealso_num-1;
if seealsonum>19 then seealsonum:=19;
end
else seealsonum:=255;
entrytype:=2;
previous:=prev;
next:=nxt;
end;
procedure read_entry(fp:longint); {Read some kind of file entry}
begin
seek(f,fp);
id:=read_word;
case id of
0: read_short_entry;
1: read_long_entry;
end;
if ((id=0) or (level=0)) then parent[level]:=fp;
end;
procedure scrollinsert(addo_ins,directf:byte); {Insert for the scroll procedure}
var sl:byte;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
if directf=0 then dec(offset) else inc(offset);
for i:=0 to addo_ins-1 do
begin
writestring(2,4+i+sl,a1,1,78,scrollbuffer[i+offset]);
end;
end;
procedure scroll(direction:byte); {Scroll text screen}
var addo,sl:byte;
begin
addo:=(scrtypeflag*13)+8;
if scrtypeflag=0 then sl:=startline else sl:=0;
if scrtypeflag=1 then inc(addo,lo(numrows)-24);
if entrytype=1 then
begin
removecursor;
if direction=0 then
begin
if curpos>0 then
begin
dec(curpos);
end
else
begin
if offset>0 then scrollinsert(addo,0);
end;
end
else
begin
if curpos<addo-1 then
begin
if curpos<bufferlength then
begin
inc(curpos);
end;
end
else
begin
if offset+addo<bufferlength+1 then scrollinsert(addo,1);
end;
end;
insertcursor;
end
else
begin
if direction=0 then
begin
if offset>0 then scrollinsert(addo,0);
end
else
begin
if offset+addo<bufferlength+1 then scrollinsert(addo,1);
end;
end;
if curpos>7 then addo:=curpos-7 else addo:=0;
if scrtypeflag=0 then for i:=4 to 11 do for j:=2 to 79 do smallscreen[i,j]:=screen[i+startline,j] else
for i:=4 to 11 do for j:=2 to 79 do smallscreen[i,j]:=screen[i+addo,j];
if scrtypeflag=0 then j:=10 else j:=lo(numrows)-1;
for i:=5 to j do screen[i+sl,80].att:=$07;
i:=(((curpos+offset)*(j-4)) div (bufferlength+1))+5;
if i>j then i:=j;
screen[i+sl,80].att:=$40;
end;
procedure keycommons; {General screen repaint}
begin
if scrtypeflag=0 then
begin
makesmall(startline);
if entrytype=1 then removecursor;
i:=0;
while ((i<bufferlength+1) and (i<8)) do
begin
writestring(2,4+i+startline,a1,1,78,scrollbuffer[i+offset]);inc(i);
end;
if i<8 then for i:=i to 7 do
begin
writestring(2,4+i+startline,a1,0,78,' ');
end;
for i:=4 to 11 do for j:=2 to 79 do smallscreen[i,j]:=screen[i+startline,j];
if entrytype=1 then insertcursor;
end
else
begin
makelarge;
end;
end;
procedure pgup; {Page up procedure for the text screen}
var addo:byte;
begin
addo:=(scrtypeflag*13)+8;
if scrtypeflag=1 then inc(addo,lo(numrows)-24);
if entrytype=1 then
begin
if curpos>0 then
begin
removecursor;
curpos:=1;
end
else
begin
dec(offset,addo-2);
if ((offset<1) or (offset>10000)) then offset:=1;
end;
end
else
begin
curpos:=0;
dec(offset,addo-2);
if ((offset<1) or (offset>10000)) then offset:=1;
end;
scroll(0);
end;
procedure pgdn; {Page down procedure for the text screen}
var addo:byte;
begin
addo:=(scrtypeflag*13)+8;
if scrtypeflag=1 then inc(addo,lo(numrows)-24);
if entrytype=1 then
begin
if curpos<addo-1 then
begin
removecursor;
curpos:=addo-2;
if curpos>bufferlength-1 then curpos:=bufferlength-1;
end
else
begin
inc(offset,addo-2);
if offset+addo>bufferlength then offset:=bufferlength-addo;
end;
end
else
begin
curpos:=addo-1;
inc(offset,addo-2);
if offset+addo>bufferlength then offset:=bufferlength-addo;
if offset>10000 then offset:=0;
end;
scroll(1);
end;
procedure getstreng; {Read string from keyboard and echo it on screen}
var chii:word;
stl,sl:byte;
chin:char;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
streng:='';stl:=0;
writestring(15,4+sl,a1+128,0,0,#219);
repeat
keyread(chii);chin:=chr(lo(chii));
if ((31<chii) and (chii<256) and (length(streng)<62)) then
begin
writestring(15+stl,4+sl,a1,0,0,upcase(chin));
streng:=streng+upcase(chin);
inc(stl);
writestring(15+stl,4+sl,a1+128,0,0,#219);
end;
if ((chii=8) and (length(streng)>0)) then
begin
writestring(15+stl,4+sl,a1,0,0,#0);
streng:=copy(streng,1,length(streng)-1);
dec(stl);
writestring(15+stl,4+sl,a1+128,0,0,#219);
end;
until ((chii=13) or (chii=27));
if chii=27 then streng:='';
end;
procedure s_o_l_insert; {Insert for the search-or-load procedure}
var savl:byte;
begin
screen:=savedscreen;
if scrtypeflag=1 then
begin
savl:=startline;
startline:=0;
createsmall;
makelarge;
startline:=savl;
end
else createsmall;
insertcursor;
makemenu(3);
end;
procedure exitmenus; {Remove pull-down menu}
var add:byte;
begin
mlevel:=0;menuy:=0;wix:=0;wiy:=0;
if scrtypeflag=0 then makesmall(startline) else
begin
for j:=1 to 80 do screen[3,j]:=smallscreen[3,j];
i:=0;
while ((i+offset<bufferlength+1) and (i<9)) do
begin
writestring(2,4+i,a1,1,78,scrollbuffer[i+offset]);inc(i);
end;
if entrytype=1 then insertcursor;
for i:=5 to lo(numrows)-1 do screen[i,80].att:=$07;
i:=(((curpos+offset)*(lo(numrows)-5)) div (bufferlength+1))+5;
if i>lo(numrows)-1 then i:=lo(numrows)-1;
screen[i,80].att:=$40;
end;
end;
procedure search_or_load(typ:byte;namest:string); {Search for entry or load new NG file}
var sl,savl:byte;
tmpchr:word;
savst:string;
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
wix:=2;wiy:=2+sl;
frame1(76,3);
writestring(4,4+sl,a1,0,74,namest);
savst:=streng;
getstreng;
if streng<>'' then
begin
if typ=0 then
begin
{SEARCH begins - feel free to add this yourself}
if scrtypeflag=0 then
begin
makesmall(startline);
end
else
begin
makelarge;
end;
wix:=0;wiy:=0;
{SEARCH ends - feel free to add this yourself}
end
else
begin {Load new guide file}
erro:=0;
if pos('.',streng)=0 then streng:=streng+'.NG';
if ((pos('\',streng)=0) and (pos(':',streng)=0)) then
writestring(4,4+sl,a1,0,74,' Loading '+homedir+streng+' - please wait') else
writestring(4,4+sl,a1,0,74,' Loading '+streng+' - please wait');
close(f);
twonitvars;
if ((pos('\',streng)=0) and (pos(':',streng)=0)) then assign(f,homedir+streng) else assign(f,streng);
reset(f,1);
if ioresult<>0 then
begin
sllut(3);
end;
if erro=0 then
begin
read_header(1);
end;
if erro=0 then
begin
read_menus(1);
end;
if erro=0 then
begin
read_entry(mennu[0,1].filptr);
s_o_l_insert;
end
else
begin {If there are any errors, we reload the old guide file}
keyread(tmpchr);
streng:=savst;
twonitvars;
if ((pos('\',streng)=0) and (pos(':',streng)=0)) then assign(f,homedir+streng) else assign(f,streng);
reset(f,1);
read_header(1);
read_menus(1);
read_entry(mennu[0,1].filptr);
s_o_l_insert;
end;
end;
end
else exitmenus;
end;
procedure escape_insert; {Insert for the ESC key handler}
begin
dec(level);
read_entry(parent[level]);
if ((level>0) or (entrytype=1)) then
begin
curpos:=pcurpos[level];offset:=poffset[level];
end;
sapos:=0;
keycommons;
ch:=0;
end;
procedure keyhandler; {Reads key from keyboard and decides which action to take}
var sl:byte;
tmpchr,tmo,tmc:word;
begin
repeat
keyread(ch);
case ch of
43: begin {'+' key - moves small screen one line down}
if scrtypeflag=0 then
begin
if startline<lo(numrows)-11 then
begin
inc(startline);
for i:=startline+11 downto startline do for j:=1 to 80 do screen[i+1,j]:=screen[i,j];
for j:=1 to 80 do screen[startline,j]:=savedscreen[startline,j];
if mlevel=1 then inc(wiy);
end;
end;
end;
45: begin {'-' key - moves small screen one line up}
if scrtypeflag=0 then
begin
if startline>0 then
begin
dec(startline);
for i:=startline to startline+11 do for j:=1 to 80 do screen[i+1,j]:=screen[i+2,j];
for j:=1 to 80 do screen[13+startline,j]:=savedscreen[13+startline,j];
if mlevel=1 then dec(wiy);
end;
end;
end;
328: if mlevel=0 then scroll(0) else {UpArrow key}
begin
removemlcursor;
if menuy>0 then dec(menuy) else menuy:=itemlist[menux-3]-2;
insertmlcursor;
end;
336: if mlevel=0 then scroll(1) else {DownArrow key}
begin
removemlcursor;
if menuy<itemlist[menux-3]-2 then inc(menuy) else menuy:=0;
insertmlcursor;
end;
329: if mlevel=0 then pgup; {PgUp key}
337: if mlevel=0 then pgdn; {PgDn key}
327: if entrytype=2 then {Home key - go to previous entry}
begin
if level>0 then
begin
if previous>0 then
begin
read_entry(previous);
curpos:=0;offset:=0;sapos:=0;
keycommons;
end;
end;
end;
335: if entrytype=2 then {End key - go to next entry}
begin
if level>0 then
begin
if next>0 then
begin
read_entry(next);
curpos:=0;offset:=0;sapos:=0;
keycommons;
end;
end;
end;
331: if mlevel=0 then {LeftArrow key}
begin
if ((entrytype=1) or (level=0)) then movemenucursor(0) else moveseealso(0);
end
else
begin
exitmenus;
movemenucursor(0);
end;
333: if mlevel=0 then {RightArrow key}
begin
if ((entrytype=1) or (level=0)) then movemenucursor(1) else moveseealso(1);
end
else
begin
exitmenus;
movemenucursor(1);
end;
9 : begin {Tab key - toggles between small and large screens}
if scrtypeflag=0 then
begin
scrtypeflag:=1;
makelarge;
end
else
begin
scrtypeflag:=0;
makesmall(startline);
if mlevel=1 then makemenu(menux);
end;
end;
13: if ((entrytype=1) or (level=0)) then {ENTER key handler}
begin
if menux=0 then
begin
tmc:=curpos;tmo:=offset;
pcurpos[level]:=curpos;poffset[level]:=offset;
curpos:=0;offset:=0;
inc(level);
read_entry(infobuffer[tmc+tmo]);
keycommons;
end
else if menux=1 then
begin
search_or_load(0,' Look for:');
end
else if menux=2 then
begin
search_or_load(1,' New file:');
end
else
begin
if mlevel=0 then makemenu(menux)
else
begin
read_entry(mennu[menux-3,menuy+1].filptr);
if entrytype=2 then inc(level);
xchoice:=menux-3;ychoice:=menuy;
curpos:=0;offset:=0;mlevel:=0;menuy:=0;
keycommons;
end;
end;
end
else
begin
if seealsonum<>255 then
begin
read_entry(seealso[sapos].filptr);
curpos:=0;offset:=0;sapos:=0;
keycommons;
end;
end;
27: if ((entrytype=2) and (level>0)) then {ESC key handler}
begin
escape_insert;
end
else if mlevel=1 then
begin
exitmenus;
ch:=0;
end
else
begin
if level>0 then
begin
escape_insert;
end
else
begin
if scrtypeflag=0 then sl:=startline else sl:=0;
wix:=2;wiy:=2+sl;
frame1(40,3);
writestring(4,4+sl,a3,0,38,' Do you really want to quit (Y/N) ?');
repeat
keyread(tmpchr);
until ((upcase(chr(lo(tmpchr)))='Y') or (upcase(chr(lo(tmpchr)))='N'));
writestring(40,4+sl,a3,0,0,upcase(chr(lo(tmpchr))));
i:=0;while i<65535 do inc(i);
if upcase(chr(lo(tmpchr)))='N' then
begin
if scrtypeflag=0 then makesmall(startline) else makelarge;
ch:=0;
end;
end;
end;
end;
until ch=27;
end;
function sizeofcode:word; {TESS function to decide size of resident code}
var used:word;
begin
used:=seg(heapptr^)-prefixseg;
sizeofcode:=used;
end;
{$F+} procedure tsrmainproc; {$F-} {TESS resident procedure entry point}
begin
if ((lo(screenmode)<4) or (lo(screenmode)=7)) then
begin
savedcsr:=csr;
threenitvars;
startline:=0;
scrtypeflag:=0;
read_entry(mennu[0,1].filptr);
createsmall;
insertcursor;
makemenu(3);
keyhandler;
screen:=savedscreen;
if restorecrsr(savedcsr) then i:=i;
end
else
begin
tessbeep;
end;
end;
{$F+} procedure tsrcleanup(removetsr:boolean); {$F-} {TESS install-or-remove procedure entry point}
begin
if (removetsr) then
begin
close(f);
erroraddr:=NIL;
end
else
begin
initscreen;
read_header(0);
read_menus(0);
write('NG_CLONE installed Hotkey: Ctrl-Alt-G');
end;
end;
begin {Main loop and command-line parser}
directvideo:=false; {Force write and writeln through BIOS}
write('Norton Guides Clone V. 1.0 (c) 1989 J.P.Pedersen');
initvars; {Initialize global variables}
tsrstring:='NG_CLONE'; {TESS ID string - rather original, eh?}
tssetadrtp4(@tsrmainproc,2); {Set TESS entry point}
tssetadrtp4(@tsrcleanup,5); {Set TESS entry point}
defptr:=NIL; {TESS stack pointer #1}
stackptr:=@backstack[(sizeof(backstack)-3)]; {TESS stack pointer #2}
tssetstack(defptr^,stackptr^); {Initialize TESS stacks}
if (tscheckresident(tsrstring[1],idnum)=$FFFF) then {Is NG_CLONE already resident?}
begin
if ((paramstr(1)='/U') or (paramstr(1)='/u')) then {If uninstall command, then do so}
begin
writeln('NG_CLONE removed from memory');
i:=tsrelease(idnum);
halt(0);
end
else
begin {Else report presence and exit}
write('NG_CLONE already installed Hotkey: Ctrl-Alt-G');
halt(0);
end;
end
else
begin {Else}
if ((paramstr(1)='/U') or (paramstr(1)='/u')) then {If program is not resident, it cannot be removed!}
begin
writeln('NG_CLONE has not been installed!');
halt(0);
end;
end;
if ((paramstr(1)='/?') or (paramstr(1)='/h') or (paramstr(1)='/H')) then slutlort(0); {Write usage info and exit}
if paramcount<2 then slutlort(1); {Command-line syntax error}
if paramcount>3 then slutlort(2); {Command-line syntax error}
streng:=paramstr(1);
if paramcount=3 then homedir:=paramstr(2)+'\' else homedir:=''; {Check for ngdir entry on command-line}
if pos('.',streng)=0 then streng:=streng+'.NG'; {Expand file name}
if ((pos('\',streng)=0) and (pos(':',streng)=0)) then assign(f,homedir+streng) else assign(f,streng); {Expand further}
reset(f,1);
if ioresult<>0 then slutlort(3); {If file does not exist, terminate and write cause of death}
if (paramstr(paramcount)='+') then {Should we go resident?}
begin {OK, we let TESS do the hard work}
if (tsdoinit(tsrhot_g,tsrpopalt+tsrpopctrl,tsrusepopup,sizeofcode)<>0) then writeln('Cannot install');
end
else if (paramstr(paramcount)='-') then {Non-resident mode wanted}
begin
savedcsr:=csr;
initscreen;
read_header(0);
read_menus(0);
read_entry(mennu[0,1].filptr);
createsmall;
insertcursor;
makemenu(3);
keyhandler;
screen:=savedscreen;
close(f);
if restorecrsr(savedcsr) then i:=i;
end
else slutlort(0); {If there is no (+/-) switch to determine mode , it is an error}
end.